home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _58234310b6f81fde18d31099d5fd71e4 < prev    next >
Encoding:
Text File  |  2002-06-17  |  13.3 KB  |  468 lines
  1. package PPM::Repository::PPM3Server;
  2.  
  3. use strict;
  4. use SOAP::Lite 0.51;
  5. use Data::Dumper;
  6. use File::Basename qw(basename);
  7. use Digest::MD5 ();
  8.  
  9. use PPM::Config;
  10. use PPM::Sysinfo;
  11. use PPM::Result qw(Ok Error Warning List);
  12. use PPM::PPD;
  13.  
  14. use base qw(PPM::Repository);
  15. our $VERSION = '3.06';
  16. our $PROTOCOL_VERSION = 3;
  17.  
  18. #==============================================================================
  19. # Note: the server exports this interface:
  20. #   describe('language', 'package name');
  21. #   getppd('language', 'package name');
  22. #   search('language', 'query', 'case-insensitive');
  23. #   uptodate('language', 'package name', 'osd-version');
  24. #   ppm_protocol();
  25. #
  26. # Note: definition of package_entity:
  27. #   package_entity {
  28. #    repository_url
  29. #       target_type
  30. #       target_name
  31. #       package_name
  32. #       package_version
  33. #   }
  34. #
  35. # This part of the interface is for profile management:
  36. #   profile_create('name');
  37. #   profile_delete('name');
  38. #   profile_save('name', package_entity(s));
  39. #   profile_info('name');
  40. #   profile_target_rename('name', 'oldtarget', 'newtarget');
  41. #   profile_rename('oldname', 'newname'); # XXX: emulated on client-side!
  42. #
  43. # This part is for profile tracking:
  44. #   installed(package_entity);
  45. #   removed(package_entity);
  46. #   upgraded(package_entity);
  47. #==============================================================================
  48.  
  49. sub init {
  50.     my $o = shift;
  51.     my $file = PPM::Config::get_license_file();
  52.  
  53.     $o->{licfile} = $file;
  54.     $o->{mtime} = 0;
  55.     $o->{license} = undef;
  56. }
  57.  
  58. sub check_license {
  59.     my $o = $_[0];
  60.     my $file = $o->{licfile};
  61.  
  62.     # Reset state unless the license file exists
  63.     goto &init unless -f $file;
  64.  
  65.     # Used the cached license unless the license file has changed on disk
  66.     my $f_mtime = ((stat($file))[9]);
  67.     my $l_mtime = $o->{mtime};
  68.     return unless ($f_mtime > $l_mtime or $file ne $o->{liclast});
  69.  
  70.     # Update the cache from the disk
  71.     if (open (my $LICENSE, $file)) {
  72.     $o->{mtime}   = $f_mtime;
  73.     $o->{license} = do { local $/; <$LICENSE> };
  74.     $o->{liclast} = $file;
  75.     close ($LICENSE) or die "can't close license file $file: $!";
  76.     }
  77. }
  78.  
  79. sub search {
  80.     my $o = shift;
  81.     my $target = shift;
  82.     my $query = shift;
  83.     my $casei = shift;
  84.  
  85.     # Get all my arguments together:
  86.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  87.     my @headers = $o->mkheaders(target => $target);
  88.     my $response = eval {
  89.     $o->{client}->search($target_t, $query, $casei, @headers)->result;
  90.     };
  91.     my $err = $o->errors($response);
  92.     return $err unless $err->ok;
  93.     
  94.     my @results;
  95.     for my $res (@{$response->{'results'}}) {
  96.     my $h = {
  97.             name => $res->[0], 
  98.             version => $res->[1],
  99.             abstract => $res->[2],
  100.         };
  101.         my $ppd = PPM::Repository::PPM3Server::PPD->new($h, 0);
  102.     @$ppd{qw(rep id)} = ($o, $ppd->name);
  103.     push @results, $ppd;
  104.     }
  105.     List(@results);
  106. }
  107.  
  108. sub describe {
  109.     my $o = shift;
  110.     my $target = shift;
  111.     my $pkg = shift;
  112.     
  113.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  114.     my @headers = $o->mkheaders(target => $target);
  115.     my $response = eval {
  116.     $o->{client}->describe($target_t, $pkg, @headers)->result;
  117.     };
  118.     my $err = $o->errors($response);
  119.     return $err unless $err->ok;
  120.     
  121.     my $ppd = PPM::Repository::PPM3Server::PPD->new($response->{'results'}, 1);
  122.     @$ppd{qw(rep id)} = ($o, $ppd->name);
  123.     Ok($ppd);
  124. }
  125.  
  126. sub getppd_obj {
  127.     my $o = shift;
  128.     my $target = shift;
  129.     my $pkg = shift;
  130.     my $ppd_txt = $o->getppd($target, $pkg);
  131.     return $ppd_txt unless $ppd_txt->ok;
  132.     Ok(PPM::PPD::->new($ppd_txt->result, $o, $pkg));
  133. }
  134.  
  135. sub getppd {
  136.     my $o = shift;
  137.     my $target = shift;
  138.     my $pkg = shift;
  139.     
  140.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  141.     my @headers = $o->mkheaders(target => $target);
  142.     my $response = eval {
  143.     $o->{client}->getppd($target_t, $pkg, @headers)->result;
  144.     };
  145.     my $err = $o->errors($response);
  146.     return $err unless $err->ok;
  147.     Ok($response->{'results'});
  148. }
  149.  
  150. sub uptodate {
  151.     my $o = shift;
  152.     my $target = shift;
  153.     my $pkg = shift;
  154.     my $version = shift;
  155.     
  156.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  157.     my @headers = $o->mkheaders(target => $target);
  158.     my $response = eval {
  159.     $o->{client}->uptodate($target_t, $pkg, $version, @headers)->result;
  160.     };
  161.     my $err = $o->errors($response);
  162.     return $err unless $err->ok;
  163.  
  164.     # If the status is false (it's out of date) return the version on the
  165.     # server as the new version.
  166.     my $newversion = '';
  167.     unless ($response->{'results'}) {
  168.     my $ppd = $o->describe($target, $pkg)->result;
  169.     $newversion = $ppd->version;
  170.     }
  171.     List($response->{'results'}, $newversion);
  172. }
  173.  
  174. #=============================================================================
  175. # Profiles
  176. #=============================================================================
  177. sub profile_list {
  178.     my $o = shift;
  179.     my @headers = $o->mkheaders;
  180.     my $response = eval {
  181.     $o->{client}->profile_list(@headers)->result;
  182.     };
  183.     my $err = $o->errors($response);
  184.     return $err unless $err->ok;
  185.  
  186.     my @profiles = @{$response->{'results'}};
  187.     List(@profiles);
  188. }
  189.  
  190. sub profile_add {
  191.     my $o = shift;
  192.     my $name = shift;
  193.     my @headers = $o->mkheaders;
  194.     my $response = eval {
  195.     $o->{client}->profile_create($name, @headers)->result;
  196.     };
  197.     my $err = $o->errors($response,"profile_create");
  198.     return $err unless $err->ok;
  199.     Ok();
  200. }
  201.  
  202. sub profile_del {
  203.     my $o = shift;
  204.     my $name = shift;
  205.     my @headers = $o->mkheaders;
  206.     my $response = eval {
  207.     $o->{client}->profile_delete($name, @headers)->result;
  208.     };
  209.     my $err = $o->errors($response,"profile_delete");
  210.     return $err unless $err->ok;
  211.     Ok();
  212. }
  213.  
  214. sub profile_save {
  215.     my $o = shift;
  216.     my $name = shift;
  217.     my @entries = @_;
  218.     my @headers = $o->mkheaders;
  219.     my $response = eval {
  220.     $o->{client}->profile_save($name, \@entries, @headers)->result;
  221.     };
  222.     my $err = $o->errors($response);
  223.     return $err unless $err->ok;
  224.     Ok();
  225. }
  226.  
  227. sub profile_info {
  228.     my $o = shift;
  229.     my $name = shift;
  230.     my @headers = $o->mkheaders;
  231.     my $response = eval {
  232.     $o->{client}->profile_info($name, @headers)->result;
  233.     };
  234.     my $err = $o->errors($response);
  235.     return $err unless $err->ok;
  236.     my $entries = $response->{'results'};
  237.     List(@$entries);
  238. }
  239.  
  240. sub profile_target_rename {
  241.     my $o = shift;
  242.     my $profile = shift;
  243.     my $oldname = shift;
  244.     my $newname = shift;
  245.     my @headers = $o->mkheaders;
  246.     my $response = eval {
  247.     my @args = ($profile, $oldname, $newname);
  248.     $o->{client}->profile_target_rename(@args, @headers)->result;
  249.     };
  250.     my $err = $o->errors($response);
  251.     return $err unless $err->ok;
  252.     Ok();
  253. }
  254.  
  255. # This is a bit of a temporary hack: the server doesn't actually expose a
  256. # profile_rename() method, so I emulate it by retrieving the doomed profile,
  257. # saving it as the new profile, and deleting the other. I suspect this will be
  258. # moved over to the server in future, because it can be lightening-fast if
  259. # done directly in the database.
  260. sub profile_rename {
  261.     my $o = shift;
  262.     my $oldprof = shift;
  263.     my $newprof = shift;
  264.  
  265.     # Retrieve the old profile:
  266.     my $info = $o->profile_info($oldprof);
  267.     return $info unless $info->ok;
  268.  
  269.     # Delete the new one, but don't croak if it returns an error. This allows
  270.     # us to rename over old profiles.
  271.     my $purge = $o->profile_del($newprof);
  272.  
  273.     # Create the new one:
  274.     my $new = $o->profile_add($newprof);
  275.     return $new unless $new->ok;
  276.  
  277.     # Save the new one:
  278.     my $save = $o->profile_save($newprof, $info->result_l);
  279.     return $save unless $save->ok;
  280.  
  281.     # Delete the old one:
  282.     my $del = $o->profile_del($oldprof);
  283.     return $del unless $del->ok;
  284.  
  285.     Ok();
  286. }
  287.  
  288. #=============================================================================
  289. # Profile Tracking:
  290. #=============================================================================
  291. sub installed {
  292.     my $o = shift;
  293.     my $profile = shift;
  294.     my @l = @_;
  295.     my @headers = $o->mkheaders;
  296.     my $response = eval {
  297.     $o->{client}->profile_pkgs_installed($profile, \@l, @headers)->result;
  298.     };
  299.     $o->errors($response);
  300. }
  301.  
  302. sub upgraded {
  303.     my $o = shift;
  304.     my $profile = shift;
  305.     my @l = @_;
  306.     my @headers = $o->mkheaders;
  307.     my $response = eval {
  308.     $o->{client}->profile_pkgs_upgraded($profile, \@l, @headers)->result;
  309.     };
  310.     $o->errors($response);
  311. }
  312.  
  313. sub removed {
  314.     my $o = shift;
  315.     my $profile = shift;
  316.     my @l = @_;
  317.     my @headers = $o->mkheaders;
  318.     my $response = eval {
  319.     $o->{client}->profile_pkgs_removed($profile, \@l, @headers)->result;
  320.     };
  321.     $o->errors($response);
  322. }
  323.  
  324. # Calculate a hash of the current user, plus the host and the install time.
  325. # This is useful for tracking how many "users" are using each installation.
  326. my $userhash = PPM::Sysinfo::generate_user_key();
  327. my $insthash = PPM::Sysinfo::inst_key();
  328.  
  329. # This little helper builds SOAP Headers we can use to send along with the
  330. # SOAP request. The license and other information is sent along with it.
  331. sub mkheaders {
  332.     my $o = shift;
  333.     my %args = @_;
  334.     my @headers;
  335.  
  336.     # By checking the license each time, we can auto-detect new licenses
  337.     # without a re-start of PPM:
  338.     $o->check_license;
  339.     push @headers, SOAP::Header->name('license', $o->{license});
  340.  
  341.     # Push on the ID of this installation of PPM:
  342.     push @headers, SOAP::Header->name('ppm_install_id', $insthash);
  343.  
  344.     # Push on a hash of the current user plus hostname & install time. Note
  345.     # that we specifically don't want to use all the same elements that went
  346.     # into the install_id of this host (hostname, insttime, os, ip_addr). We
  347.     # want to have each user get a unique string, but to munge enough extra
  348.     # uniqueness that the usernames can't be guessed just by a simple
  349.     # dictionary attack against someone sniffing the MD5 keys.
  350.     push @headers, SOAP::Header->name('user_hash', $userhash);
  351.  
  352.     # Push on the client's protocol version and "real" version:
  353.     push @headers, SOAP::Header->name('client_version', $VERSION);
  354.     push @headers, SOAP::Header->name('ppm_protocol',
  355.                       $PROTOCOL_VERSION);
  356.  
  357.     # This information has to be grabbed from the piece of software actually
  358.     # interacting with the user. Currently, there's no way to do that cleanly.
  359.     push @headers, SOAP::Header->name('useragent', 'PPM');
  360.     push @headers, SOAP::Header->name('useragent_vers', '3.0');
  361.  
  362.     # Push on target-specific stuff:
  363.     for my $k (keys %args) {
  364.     if ($k eq 'target') {
  365.         my $t = $args{$k};
  366.         push(@headers,
  367.              SOAP::Header->name('archname',
  368.                     $t->config_get("ARCHITECTURE")->result),
  369.          SOAP::Header->name('os', $t->config_get("OSVALUE")->result),
  370.          SOAP::Header->name('osvers',
  371.                      $t->config_get("OSVERSION")->result),
  372.         );
  373.     }
  374.     }
  375.     @headers;
  376. }
  377.  
  378. sub type_printable { "PPMServer 3.0" }
  379.  
  380. sub errors {
  381.     my $o = shift;
  382.     my $response = shift;
  383.     
  384.     # assuming that method name here and method name on server are usually
  385.     # equivalent.  if not, use an optional second argument to supply method
  386.     # name.
  387.     my $method = shift || (split '::', (caller(1))[3])[-1];
  388.  
  389.     if ($@) {
  390.     chomp $@;
  391.     return PPM::Repository::Result::->new("$method exception: $@.",
  392.                           $o->location,
  393.                              );
  394.     }
  395.     elsif (not defined $response) {
  396.     return
  397.       PPM::Repository::Result::->new(
  398.           "$method returned undefined results.",
  399.           $o->location,
  400.       );
  401.     }
  402.     elsif ($response->{'status'} != 0) {
  403.     return PPM::Repository::Result::->new($response->{'message'},
  404.                           $o->location,
  405.                           $response->{'status'}
  406.                          );
  407.     }
  408.     Ok();
  409. }
  410.  
  411. package PPM::Repository::PPM3Server::PPD;
  412. our @ISA = qw(PPM::PPD);
  413.  
  414. sub new {
  415.     my $this = shift;
  416.     my $class = ref($this) || $this;
  417.     my $self = bless {}, $class;
  418.     my $server_ppd = shift;
  419.     my $complete = shift;
  420.  
  421.     $self->{is_complete} = $complete;
  422.  
  423.     # Author:  "authorname (authoremail)"
  424.     if (defined $server_ppd->{'authorname'}) {
  425.         $self->{parsed}{AUTHOR} = $server_ppd->{'authorname'};
  426.         if (defined $server_ppd->{'authoremail'}) {
  427.             $self->{parsed}{AUTHOR} .= " ($server_ppd->{'authoremail'})";
  428.         }
  429.     }
  430.     
  431.     # Name, title, version, abstract:
  432.     for my $field (qw(title abstract version name)) {
  433.     $self->{parsed}{"\U$field"} = $server_ppd->{$field};
  434.     }
  435.  
  436.     # Implementations:
  437.     for my $impl (@{$server_ppd->{implementation}}) {
  438.     my $i = bless { ARCHITECTURE => $impl },
  439.               'PPM::Repository::PPM3Server::PPD::Implementation';
  440.     push @{$self->{parsed}{IMPLEMENTATION}}, $i;
  441.  
  442.     # Dependencies:
  443.     for my $dep (@{$server_ppd->{dependency}}) {
  444.         my $dep = bless { NAME => $dep->{name},
  445.                   VERSION => $dep->{version} },
  446.                 'PPM::Repository::PPM3Server::PPD::Dependency';
  447.         push @{$i->{DEPENDENCY}}, $dep;
  448.     }
  449.     }
  450.     return $self;
  451. }
  452.  
  453. sub version {
  454.     my $o = shift;
  455.     $o->version_osd;
  456. }
  457.  
  458. package PPM::Repository::PPM3Server::PPD::Implementation;
  459. our @ISA = qw(PPM::PPD::Implementation);
  460.  
  461. package PPM::Repository::PPM3Server::PPD::Dependency;
  462. our @ISA = qw(PPM::PPD::Dependency);
  463.  
  464. sub version {
  465.     my $o = shift;
  466.     $o->version_osd;
  467. }
  468.